perm filename MOVER.1[NEW,LCS] blob
sn#145110 filedate 1975-02-13 generic text, type T, neo UTF8
C****** MOVER, MVBEAM, MVBX, RTLINE, EXTEN, CLEFS
SUBROUTINE MOVER
IMPLICIT INTEGER(A-Q,S-Z)
DIMENSION R(2,200),IR(2,200)
REAL PWDS,POS,EXTEN
COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK/STF/RSTFAC(-3/4),RSTJ2
COMMON/XRN/RN(4000) /KJY/ K,JY
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
COMMON/POSI/STFF(-3/4),JJ2,POS/PTR/PWDS(250),ITEM,LL,I,IX
COMMON/ALF/INP(47),ML,RRT,RZRO,RCNT,RJSZ,ROV,RSPC,KN,RA,RB,
1 JLDGR,LDGR,JX,RW,RX,RY,RZ,JJ,RD,RQ,RE,RZZ,RN3,RN6,RV,RQ6
EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7)),(R11,RJQ(9))
1,(IR,R,RN(3101))
DATA F78F/'(78F)'/,FA1/'(A1 )'/,FA5/'(A5 )'/,RSP/.5/,RI/4.5/
JJ2=-1
J2=0
C 99=BACKUP
6 CALL VLINE(R2,R4,R5,R6)
IF(R2.GE.99)RETURN
IF(INP(1).NE.'J')GO TO 12
RRT=R5
RZRO=R4
IF(RRT.EQ.0)RRT=200
IF(RZRO.EQ.0)RZRO=.001
RCNT=0
RJSZ=RI
ASK=-1
R7=R2
R6=0
R11=0
19 IF(RCNT.GT.9)GO TO 101
ROV=RRT
RJSZ=RJSZ-.1
RCNT=RCNT+1
C TEMPORARY COUNTER
ML=1
TYPE F78F,RCNT
DO 11 KN=-3,4
RSPC=0
R8=KN
N=0
DO 2 K=1,ITEM
L=PWDS(K)
IF(RTLINE(L))GO TO 2
RA=RN(L+1)
RB=RN(L+3)
IF((RN(L+2).NE.R8.AND.RA.NE.4).OR.RB.LT.RZRO)GO TO 2
C SKIPS HOMED NOTES (IN CHORDS)
IF(RA.EQ.1)GO TO 10
27 IF(RA.GT.4.AND.RA.LT.17)GO TO 2
C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
10 N=N+1
R(1,N)=RB
IR(2,N)=L
IF(N.EQ.200)GO TO 28
C ONLY TREATS 200 ITEMS AT A TIME.
2 CONTINUE
IF(N.EQ.0)GO TO 11
28 DO 23 K=1,N
23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
C SKIPS IF ONLY BAR LINES ON THIS STAFF
GO TO 11
24 RSTJ2=RSTFAC(KN)
CALL SORT2(R,N)
C JUMP IF LAST IS A BAR LINE.
K=0
JLDGR=0
JX=0
22 K=K+1
122 L=IR(2,K)
RA=RN(L+1)
RB=0
RX=RN(L+5)
C RX=PARAM 5
RX6=RN(L+6)
RY=1
RW=AMOD(RN(L+4),100.)
IF(RA.GT.1)GO TO 4
RZ=RN(L+7)
IF(LDGR.NE.JLDGR)JLDGR=0
LDGR=0
JY=K
DO 32 JJ=JY+1,N+1
K=JJ
32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
C FOUND HOW MANY MEMBERS TO CHORD.
35 RB=0
K=K-1
RQ=0
RD=0
125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
DO 37 JJ=JY,K-1
IF(RD.NE.0)GO TO 38
C FINDS ONLY HIGH OR! LOW LED. LINE.
JR=IR(2,JJ)
RW=AMOD(RN(JR+4),100.)
IF(RW.LE.11.AND.RW.GE.2)GO TO 38
LDGR=-1
IF(RW.GT.11)LDGR=1
IF(JLDGR.EQ.LDGR)GO TO 36
JLDGR=LDGR
C LDGR IS FOR LEDGER LINES.
GO TO 38
36 RD=1.5
RQ=RD
38 IF(RB.GT.2)GO TO 222
C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
RZZ=RN(JR+7)
RE=RN(JR+5)
IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
C SPACE FOR DOT OR TAIL(IF STEM UP)
IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
C FOR CHORD TONES ON RIGHT OF STEM UP.
C LOOKS THROUGH ALL NOTES OF A CHORD.
222 IF(AMOD(RE,10.).EQ.0)GO TO 37
C JUMP IF NO ACCIS.
425 RD=2*RY+EXTEN(RE)
IF(RQ.GT.RD)RD=RQ
RQ=RD
C FUNCT. EXTEN=AMOD(X,1.)*10.
37 CONTINUE
IF(RY.NE.1)RB=RB-.5*RJSZ
C MINI NOTES NEED LESS SPACE
25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJ2
GO TO 17
4 IF(RA.NE.3)GO TO 29
RB=3
IF(RX.GT.100)RB=1.5
C CHECK ON SIZE NEEDED FOR CLEFS
29 IF(RA.NE.4)GO TO 26
RB=-RJSZ/2
RD=.9
GO TO 25
26 IF(RA.NE.18)GO TO 30
IF(RX6.GT.9.OR.RX.GT.9)GO TO 31
C CHECKS FOR 2-DIGIT METERS
RB=-1
RD=1
GO TO 25
31 RB=2
RD=3
GO TO 25
30 IF(RA.NE.17)GO TO 17
RB=2*(ABS(RX)-1)-2
C SPACES FOR CORRECT NUM OF ACCIS. RX=NUM OF ACCIS.
RD=2
GO TO 25
17 RC=(RB+RJSZ)*RSTJ2
C RJSZ=DEFAULT SIZE
JX=JX+1
R(2,JX)=RC
R(1,JX)=R(1,K)
3 IF(K.LT.N)GO TO 22
RA=R(1,1)
RB=R(2,1)
DO 13 KX=2,JX
RE=R(1,KX)
C POS. BEFORE SHIFTING
IF(ABS(RE-RA).GT..5)GO TO 14
IF(R(2,KX).GT.RB)GO TO 16
C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
GO TO 13
C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
14 RD=RA+RB-RE
IF(RD.LE.0)GO TO 16
C THERE'S ENOUGH ROOM
R4=RE+RSPC-.001
R5=1000
R8=RD
R9=0
RSPC=RSPC+RD
C RSPC SAVES TOTAL SPACE ADDED
C GO EXPAND IT
IF(R(2,KX).NE.0)GO TO 166
16 RB=R(2,KX)
13 RA=RE
11 CONTINUE
110 IF(ROV.LE.RRT+.01)GO TO 18
R4=RZRO
R5=ROV
R8=RZRO
R9=RRT-.001
C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
ML=3
IF(RJSZ.GT.4)RJSZ=4
GO TO 66
18 ML=4
R8=ROV
R9=RRT+2
C GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
R4=ROV
R5=500
166 JJ2=-1
J2=0
GO TO 66
1200 FORMAT(' MOVED TO STAFF ',F4.0/)
C****** BEGIN MOVER *******
12 TYPE 5
ML=2
ACCEPT F78F,R7,R8,R9,R11
RDIS=0
REREAD FA1,L
C FOR LPEN TYPE 'L'. BUT 4TH # MUST APPEAR WHEN NEEDED.
IF(R2.NE.88)GO TO 167
C 88, 1ST ITEM, LAST ITEM: STAFF N, MOVE HOR., MOVE VERT.
LDGR=R5
J2=R4-1
C 1ST ITEM.
R4=-500
R5=500
L=I
C ↑↑↑↑ FOR 'C'OPY
168 IF(J2.GT.LDGR)GO TO 101
JY=PWDS(J2+1)
IF(INP(1).NE.'C')L=JY
GO TO 6551
167 IF(R7.GE.99)GO TO 6
IF(R7.NE.R2)TYPE 1200,R7
IF(R2.GT.4)R7=R2
IF(L.NE.'L')GO TO 66
DO 67 K=1,2
R8=RY
CALL LPEN(R7,RY,RX)
67 IF(R7.GE.99)GO TO 6
R9=RY
66 JY=1
L=JY
IF(INP(1).EQ.'C')L=I
C C=COPY
IF(R9.NE.0)RDIS=(R9-R8)/(R5-R4)
6551 RB=RN(JY)
J2=J2+1
IF(RTLINE(JY))GO TO 7551
C IF STAFF#>4, ALL STAVES ARE MOVED.
RA=RN(JY+1)
IF(R6.GT.0.AND.R6.NE.RA)GO TO 7551
C SKIPS IF NOT SPECIAL CODE NUM.
RN3=RN(JY+3)
IF(RN3.GT.R5)GO TO 7551
RC=-1
RD=0
IF(RA.GE.5.AND.RA.LE.7)RD=-1
IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
C RC=0 FOR CODES 4,5,6
RN6=RN(JY+6)
IF(RN3.GE.R4)GO TO 8
IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.R4.OR.RN6.GE.R5)))GO TO 7551
C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
C IF INP(1)='C' MOVE TO NEW SPOT AND LEAVE OLD BEHIND.
8 IF(ASK)GO TO 100
CALL ASKIT
IF(K.EQ.'N')GO TO 7551
IF(K.EQ.'X')GO TO 1
C 'X'=EXIT
C N=NO, <CR>=YES
100 IF(INP(1).NE.'C')GO TO 9551
K=RB+2
CALL LOOP(0,K,1,L,JY,RN)
ITEM=ITEM+1
IF(JJ2)JJ2=ITEM
C JJ2 SAVES ITEM # FOR MAIN PROG.
PWDS(ITEM+1)=L+K+1
9551 IF(JJ2)JJ2=J2
C (50=CRESC., DECRESC.)
IF(R2.LT.5.OR.R2.EQ.88.)RN(L+2)=R7
IF(RA.EQ.8)GO TO 7552
C 8=STAFF. ONLY MOVES OR COPIES TO NEW STAFF NUM. OTHER PARAMS UNAFFECTED.
RQ6=RN6-R5
RX=0
RV=0
IF(RA.NE.6.OR.RB.LT.7)GO TO 21
RX=RN(L+9)
RY=RX-R5
RZ=R4-RX
IF(RN(L+10).LT.30)GO TO 221
RW=RN(L+8)
IF(RW.GE.R4.AND.RW.LE.R5)RV=-1
221 IF(RY.AND.RZ)RX=-1
C PARTIAL BEAM IS WITHIN MOVE AREA.
21 IF(R9.EQ.0)GO TO 2551
IF(RN3.GE.R4)CALL MVBX(3)
C MOVES P4 LFT-RT. ↑↑↑↑↑↑↑↑
IF(RC)GO TO 7552
IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
IF(RQ6)CALL MVBX(6)
C END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
IF(RA.NE.6)GO TO 7552
IF(RX)CALL MVBX(9)
IF(RV)CALL MVBX(8)
C ONLY TRUE WHEN RA=6
GO TO 7552
2551 IF(RN3.GE.R4)RN3=RN3+R8
RN(L+3)=RN3
IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+R8
IF(RX)CALL MVBEAM(RN,9,JY,L,R8)
IF(RV)CALL MVBEAM(RN,8,JY,L,R8)
IF(RN3.GT.ROV)ROV=RN3
C ??? NOT YET FIXED FOR ENDS OF SLURS OR LINES
7552 L=RB+3+L
IF(R11.EQ.0)GO TO 7551
1551 IF((RB.LT.3..AND.RA.NE.13.AND.RA.NE.11).OR.RA.EQ.18.OR.
1 RA.EQ.7)GO TO 7551
C 'U-D' SKIPS METER, STAFF, KEY SIG., ETC.
JX=JY
IF(INP(1).EQ.'C')JX=PWDS(ITEM)
CALL MVBEAM(RN,4,JX,JX,R11)
IF(RC.EQ.0)CALL MVBEAM(RN,5,JX,JX,R11)
7551 JY=RB+3+JY
IF(INP(1).NE.'C')L=JY
IF(R2.EQ.88)GO TO 168
IF(JY.LT.I)GO TO 6551
GO TO (16,1,19,101),ML
101 JJ2=1
1 CALL HYDPOG(3)
5 FORMAT(' TYPE NEW STAFF #, POS1, POS2, UP-DOWN # '$)
END
FUNCTION RTLINE(L)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
RTLINE=-1
IF(R2.GT.4.OR.RN(L+2).EQ.R2)RTLINE=0
END
FUNCTION EXTEN(X)
EXTEN=AMOD(X,1.)*10.
END
C THESE MOVE ENDS OF PARTIAL INNER BEAMS.
SUBROUTINE MVBEAM(R,I,JY,L,W)
C L AND JY ARE FOR MOVES TO DIFF. STAFF.
DIMENSION R(1)
Y=R(JY+I)
Z=ABS(Y)
IF(Z.LT.100.)GO TO 1
C NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
Y=AMOD(Y,100.)
X=Y+W
Z=Z-ABS(Y)+ABS(X)
C PUTS ALL INTO POSITIVE
IF(X)Z=-Z
GO TO 2
1 Z=Y+W
2 R(L+I)=Z
END
SUBROUTINE MVBX(I)
COMMON R2,JA,CENTR,J2,RJQ(20),L,RDIS,JQ(18)/KJY/K,JY/XRN/R(4000)
EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6))
R(L+I)=R8+(R(JY+I)-R4)*RDIS
END
SUBROUTINE CLEFS
DIMENSION JCLEF(11),MCLEF(700),RCMIN(4),KCLEF(11),NCLEF(350),CM(4)
COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/
EQUIVALENCE (R4,RJQ(2)),(J5,JQ(3)),(J9,JQ(7)),(KK,
1 KCLEF(11)),(R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5))
1,(R9,RJQ(7)),(NJR,RJQ(8)),(K,JCLEF(11)),(NCLEF,MCLEF(351))
1,(R3,RJQ(1))
J5=MOD(J5,100)
CALL NOZERO(R6)
IF(R7.EQ.0)R7=R6
C IF P7 = 0, IT WILL EQUAL P6.
IF(JA.GT.10)GO TO 9
NAME='CLEF0'
IF(J5.LT.20)GO TO 4
R6=R6*.3
C SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
R7=R7*.3
GO TO 4
9 IF(NAME.EQ.NJR)GO TO 4
IF(NAME.NE.0.AND.NJR.EQ.0)GO TO 4
IF(NJR.EQ.0)GO TO 8
C TO PICK UP BASIC DRAW NAME FROM P10
NAME=NJR
GO TO 4
8 TYPE 5
5 FORMAT(' SET P10=1'/)
C LEADS TO PROPER FILE CALL
4 NM=NAME+2*(J5/10)
C DRAW0 HAS ITEMS 0→9; DRAW1, 10→19; ETC. TO DRAW9, 90→99
JEZ=MOD(J5,10)+1
2 IF(NM.EQ.JNM.OR.NM.EQ.KNM)GO TO 30
C SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
C JUMP IF ALREADY IN CORE
IF(LOOKF(NM))GO TO 1111
TYPE 1112,NM
RETURN
1112 FORMAT(1XA5,' -- NOT FOUND')
1111 CALL GETFI2(NM)
IF(KX)GO TO 33
KX=-1
JNM=NM
CALL FASTI2(JCLEF,11)
CALL FASTI2(MCLEF,K)
C NEW DATA READER 6/74 -- 10/74 HOLDS 2 .DMD FILES IF THEY FIT.
IF(K.LE.350)GO TO 30
KX=0
KNM=0
GO TO 30
33 CALL FASTI2(KCLEF,11)
KX=0
IF(KK.GT.350)GO TO 1111
C JUMP BACK IF IT WON'T FIT.
CALL FASTI2(NCLEF,KK)
KNM=NM
C CHECK THE ABOVE -- FOR P5 HEIGHT CHANGE *********************
C R6 IS SIZE FACTOR
30 IF(J5.GT.3.OR.JA.NE.3)GO TO 811
C 0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)
C ↑↑↑↑↑↑↑↑ FIXUP SOMEDAY IN .DMD FILES
IF(R5.LT.100)GO TO 812
RSTJ2=.8*RSTJ2
C TO SET HGT. OF MINI CLEFS
R4=R4+CM(JEZ)
C SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
812 IF(JEZ.NE.4)GO TO 811
R4=R4+2
JEZ=3
C ABOVE IS NOW AT TOP
811 A=R4
R4=A+2.9
CALL CENTX
R4=A
L=JCLEF(JEZ)
IF(NM.EQ.KNM)L=KCLEF(JEZ)+350
IF(J9.EQ.0)GO TO 31
CALL ROTATE(MCLEF,L)
C R9=P9=DEGREES OF ROTATION (0-360)
IF(KK.GT.250)KX=0
C CHECK TO SEE IF DATA WAS WIPED OUT.
31 IF(R8.EQ.-2.OR.(R8.NE.-1.AND.IPLT.GE.0))GO TO 32
C R8=-2 OMITS FILLER DURING PLOT
DO 3 K=L+1,MCLEF(L)+L
IF(MCLEF(K).LT.200000000)GO TO 3
JEZ=MCLEF(L)-1
IF(K.GT.L+1)JEZ=JEZ-K+L+1
CALL FILLMS(JEZ,MCLEF(K),R3,CENTR,R6,R7)
GO TO 32
3 CONTINUE
C FILLS ONLY WHEN PLOTING OR R8=-1
32 CALL JDRAW(MCLEF(L),R3,CENTR,RSTJ2,R6,R7)
C 3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
END